\ disasm.part4 of 4 v1.1 NAB
\ Included by disasm.

: nib11
  op>>9 6&7?
  if ." cmpa"
    8? 1|2 to dism-size .size
    .source ,areg 6 +cycles
    else 8? 0=
      if ." cmp" .size .source ,dreg
        4 2 +if-long
      else 3 3 op-bits 1 =
      if ." cmpm" .size op .a@+ ., .a@+
       12 8 +if-long
      else ." eor" .size .dreg ,source
        8 4 +if-long
      then
    then
  then ;

: .mul
  op>>9 6&7? if 8?
    if ." muls" else ." mulu" then
    1 to dism-size
    >arg .source ,dreg 70 +cycles
  else 8? ." and" .size
    if .dreg ,source 8 4
    else .source ,dreg 4 2
    then +if-long
  then ;

: .exg  ." exg" >arg ;

: nib12
  op>>9 op dup (hex) 1f8 and case
    (hex) 188 of .exg .areg ,dreg endof
    (hex) 148 of .exg .areg ,areg endof
    (hex) 140 of .exg .dreg ,dreg endof
    >r op (hex) 1f0 and (hex) 100 =
    if  3? ." abcd" .byte
      if .-a@ ., .-a@ 18
      else .dreg ,dreg 8
      then +cycles
    else 2drop .mul
    then r> drop exit
  endcase  6 +cycles ;

: .rot$  3 * s" as ls roxro " drop swap
  chars + 3 type ;

: .rotlr
  3 and .rot$ 8? if  [char] l
  else  [char] r then emit ;

: nib14 6&7?
  if  op>>9 .rotlr 1 size$ .source
    8 +cycles
  else  op>>3 .rotlr .size op>>9 5?
    if  .dreg
    else  7 and .# .num
    then  op ,dreg 6 2 +if-long
  then ;

: nib13
  op>>9 op (hex) c0 and (hex) c0 =
  if ." adda" 8? 1|2 to dism-size
    .size .source ,areg 8 +cycles -2 +mem
  else  op (hex) 130 and (hex) 100 =
    if  ." addx" .size op 3?
     if  .-a@ ., .-a@ 18 12
      else  .dreg ,dreg 4 4
      then  +if-long
    else  ." add" .size 8?
      if  .dreg ,source 4 2 approximate
      else  .source ,dreg 4 2
      then  +if-long
    then
  then ;

: init-disasm  exact not-doing-call ;

: disasm ( -- )
  init-disasm
  dism-adr w@ to op  set-size
  12 4 op-bits select
    xt nib0 xt nib1-3 xt nib1-3 xt nib1-3
    xt nib4 xt nib5 xt nib6 xt .moveq
    xt nib8 xt nib9 xt .dw xt nib11
    xt nib12 xt nib13 xt nib14 xt .dw
  end-select  execute  a2+ ;

hex
: forth?
  case
    4E75 of  s" EXIT"  endof
    2E1C of  s" 2DROP"  endof
    DE47 of  s" CELLS"  endof
    DE5C of  s" +"  endof
    CFDC of  s" *"  endof
    3F07 of  s" DUP >R"  endof
    3E1F of  s" DROP R>"  endof
    3E17 of  s" DROP R@"  endof
    E347 of  s" 2*"  endof
    E247 of  s" 2/"  endof
    E147 of  s" >BYTE"  endof
    3E35 of  s" @"  endof
    3E1C of  s" DROP"  endof
    3907 of  s" DUP"  endof
    548C of  s" NIP"  endof
    5247 of  s" 1+"  endof
    5347 of  s" 1-"  endof
    5447 of s" CELL+"  endof
    4447 of  s" NEGATE"  endof
    8E5C of  s" OR"  endof
    CE5C of  s" AND"  endof
    4647 of  s" INVERT"  endof
    588F of  s" UNLOOP"  endof
    5257 of  s" R> 1+ >R"  endof
    drop 0 exit
  endcase  ;

variable end-word
:noname FrmAlert ;
cell+ cs@ constant palmosstub

variable initialdepth

public:

: (seeany) ( a n -- )
  depth 2 - initialdepth !
  2dup + end-word !
  swap to dism-adr
  cr 2/ 0 ?do
    dism-adr dup u. dup cell+ >r
    dup disasm
      w@ (hex) 4EAA = if
        r@ w@ palmosstub = if
          cr dism-adr u. disasm
    ."  = systrap "
    r@ cell+ w@ .systrap
        then
     then
    r> drop
    w@ forth? dup if
       ."  = " type
    else drop
    then
    cr 
   dup 4E75 =  swap 4EEA = or
    dism-adr dup  ['] cold <  and
    if  unloop exit  then
    dism-adr end-word @ =
    if  unloop exit  then
   depth initialdepth @ <>
    abort" Stack imbalance"
  loop ;

: seebase ( a. -- ) dism-base 2! ;

: seeany
  (hex) 400 \ max ins/wrd
  (seeany) ;

: seecs ( xt -- )
  dup xt>abs seebase
   xt>size 0 swap (seeany)
;

: see ' seecs ;
